Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/C/Frameworks/TransSkel 3.24/Demos/Pascal Demos/ThreadDemo/ThreadDemo.p

Text File | 1996-01-25 | 6.8 KB | 325 lines | [TEXT/CWIE]

{
    Threads - TransSkel Thread Manager demonstration application

    This is a very simple-minded demonstration. It puts up a single
    window that draws a horizontal line, a vertical line, and an oval
    whose horizontal and vertical axes are the same length as the current
    lengths of the horizontal and vertical lines.  Each of the lines
    and the oval are drawn independently, using three threads.  In order
    to emphasize the independent nature of the three threads, the
    graphical object draw by each updates at a different rate.

    23 Jul 95 Version 1.00, Paul DuBois
}

program ThreadDemo;

uses
    Types, Memory, SegLoad, Events, QuickDraw, Windows, Dialogs, Menus,
    TextUtils, ToolUtils, Processes, Threads, TransSkel;

const

{ resource numbers }

    aboutAlrtRes = 1000;                { About box }
    errAlrtRes = 1001;                    { error alert }
    fileMenuNum = skelAppleMenuID + 1;    { File menu }

{ error string resource numbers }

    noThreadManager = 1000;
    noThread = 1001;

    windowTitle = 'ThreadDemo';
    windowWidth = 300;
    windowHeight = 120;

    maxLineLen = 100;

{ thread update times }

    thread1Update = 1;
    thread2Update = 3;
    thread3Update = 2;

{ File menu item numbers }

    quit = 1;

var

    fileMenu: MenuHandle;

    length1: Integer;    { horizontal line length }
    length2: Integer;    { vertical line length }

    refTime1: Longint;
    delta1: Longint;
    refTime2: Longint;
    delta2: Longint;
    refTime3: Longint;
    rect3: Rect;

    time: Longint;
    time2: Longint;

procedure
Die (strNum: Integer);
var
    h: StringHandle;
    flags: SignedByte;
    ignore: Integer;
begin
    h := GetString (strNum);
    if (h <> StringHandle (nil)) then
        begin
            flags := HGetState(Handle(h));
            HLock (Handle (h));
            ParamText(h^^, '', '', '');
            HSetState (Handle(h), flags);
        end
    else
        ParamText ('An unknown error occurred.', '', '', '');

    ignore := SkelAlert (errAlrtRes, SkelDlogFilter (nil, true),
                                        skelPositionOnParentDevice);
    SkelRmveDlogFilter;
    SkelCleanup;
    ExitToShell;
end;


{--------------------------------------------------------------------}
{ Menu handling procedures }
{--------------------------------------------------------------------}

{ Handle selection of "About Hello..." item from Apple menu }

procedure
DoAppleMenu (item: Integer);
var
    ignore: Integer;
begin
    ignore := SkelAlert(aboutAlrtRes, SkelDlogFilter (nil, true),
                                        skelPositionOnParentDevice);
    SkelRmveDlogFilter;
end;


{ Process selection from File menu }

procedure
DoFileMenu (item: Integer);
begin
    case item of
        quit:
            SkelStopEventLoop;
    end;
end;


{ Initialize menus.  Tell TransSkel to process the Apple menu }
{ automatically, and associate the proper procedure with the }
{ File menu. }

procedure
SetupMenus;
var
    ignore: Boolean;
begin
    SkelApple ('About ThreadDemo…', @DoAppleMenu);
    fileMenu := NewMenu (fileMenuNum, 'File');
    AppendMenu (fileMenu, 'Quit/Q');
    ignore := SkelMenu(fileMenu, @DoFileMenu, nil, false, false);

    DrawMenuBar;
end;


{--------------------------------------------------------------------}
{ Window handling procedures }
{--------------------------------------------------------------------}


procedure
Clobber;
var
    w: WindowPtr;
begin
    GetPort (w);
    DisposeWindow (w);

    { should really dispose of threads here }
end;


{--------------------------------------------------------------------}
{ Thread handling procedures }
{--------------------------------------------------------------------}


function
DoThread1 (threadParam: Ptr): Ptr;
var
    ignore: OSErr;
begin
    while (true) do
    begin
        if (TickCount () >= refTime1) then
            begin
                PenMode (patBic);
                MoveTo (60 - (maxLineLen div 2), 60);
                LineTo (60 + (maxLineLen div 2), 60);
                PenNormal;
                MoveTo (60 - (length1 div 2), 60);
                LineTo (60 + (length1 div 2), 60);
                if (delta1 > 0) then
                    begin
                        if (length1 >= maxLineLen) then
                            delta1 := -delta1;
                    end
                else
                    begin
                        if (length1 <= 0) then
                            delta1 := -delta1;
                    end;
                length1 := length1 + delta1;
                refTime1 := TickCount() + thread1Update;
            end;
        ignore := YieldToAnyThread;
    end;
    DoThread1 := nil;            { will never be reached }
end;


function
DoThread2 (threadParam: Ptr): Ptr;
var
    ignore: OSErr;
begin
    while (true) do
    begin
        if (TickCount () >= refTime2) then
            begin
                PenMode (patBic);
                MoveTo (150, 60 - (maxLineLen div 2));
                LineTo (150, 60 + (maxLineLen div 2));
                PenNormal;
                MoveTo (150, 60 - (length2 div 2));
                LineTo (150, 60 + (length2 div 2));
                if (delta2 > 0) then
                    begin
                        if (length2 >= maxLineLen) then
                            delta2 := -delta2;
                    end
                else
                    begin
                        if (length2 <= 0) then
                            delta2 := -delta2;
                    end;
                length2 := length2 + delta2;
                refTime2 := TickCount() + thread2Update;
            end;
        ignore := YieldToAnyThread;
    end;
    DoThread2 := nil;            { will never be reached }
end;


{
    Draw an oval with the dimensions of the horizontal and vertical lines
    being drawn in threads 1 and 2.
}

function
DoThread3 (threadParam: Ptr): Ptr;
var
    ignore: OSErr;
begin
    while (true) do
    begin
        if (TickCount () >= refTime3) then
            begin
                EraseOval (rect3);
                SetRect (rect3, 0, 0, length1, length2);
                OffsetRect (rect3, 240 - (length1 div 2), 60 - (length2 div 2));
                FrameOval (rect3);
                refTime3 := TickCount() + thread3Update;
            end;
        ignore := YieldToAnyThread;
    end;
    DoThread3 := nil;            { will never be reached }
end;


{ Create window and install handler for it. }

procedure
WindInit;
var
    w: WindowPtr;
    bounds: Rect;
    ignore: Boolean;
    dummyID: ThreadID;
begin
    SetRect (bounds, 0, 0, windowWidth, windowHeight);
    if (SkelQuery (skelQHasColorQD) <> 0) then
        w := NewCWindow (nil, bounds, windowTitle, false,
                        noGrowDocProc, WindowPtr(-1), false, 0)
    else
        w := NewWindow (nil, bounds, windowTitle, false,
                        noGrowDocProc, WindowPtr(-1), false, 0);
    SkelPositionWindow (w, skelPositionOnMainDevice,
                                    FixRatio(1, 2), FixRatio(1, 5));
    ignore := SkelWindow (w, nil, nil, nil, nil, nil, @Clobber, nil, false);

    SelectWindow (w);
    ShowWindow (w);
    SkelDoUpdates;
    SkelDoEvents (updateMask + activMask);


    if (NewThread (kCooperativeThread, @DoThread1, nil, 0,
                    kCreateIfNeeded, nil, dummyID) <> noErr) then
    begin
        Die (noThread);
    end;
    if (NewThread (kCooperativeThread, @DoThread2, nil, 0,
                    kCreateIfNeeded, nil, dummyID) <> noErr) then
    begin
        Die (noThread);
    end;
    if (NewThread (kCooperativeThread, @DoThread3, nil, 0,
                    kCreateIfNeeded, nil, dummyID) <> noErr) then
    begin
        Die (noThread);
    end;
end;


begin
    length1 := 0;
    refTime1 := 0;
    delta1 := 4;

    length2 := 0;
    refTime2 := 0;
    delta2 := 4;

    refTime3 := 0;
    SetRect (rect3, 0, 0, 0, 0);

    SkelInit (nil);
    if (SkelQuery (skelQHasThreads) = 0) then
        Die (noThreadManager);
    SetupMenus;
    WindInit;
    SkelGetWaitTimes (time, time2);            { set background wait time }
    SkelSetWaitTimes (time, time);            { to same as foreground time }
    SkelSetThreadTimes (1, 1);
    SkelEventLoop;                            { loop 'til Quit selected }
    SkelCleanup;                            { clean up }
end.